#lang racket

;;;
;;; Modules and Dependencies
;;;

(require games/cards racket/gui racket/class racket/unit
         racket/include
         "sections/flower-dialog.rkt"
         "card-faces/loader.rkt")

;(load "card-logic.rkt")
(include (file "sections/pretext.rkt"))

;; The layout can be any file with a class fullfilling the
;; regular layout interface. (See layout96l.rkt)
(include (file "sections/layout96l.rkt"))


;;
;; Flowers
;;
;; Now this is the stupid approach to class redefinition (see
;; Guile/GOOPS). We need each card object to have a back link to its
;; stack. While card% does feature a home-region where region is the
;; "view" of the stack the region structure does not provide a list of
;; cards and thus it does not keep track of the sequence of cards. We
;; do this in the model with a list (see stack%). Then the message
;; passing protocol for the region callbacks gives us a list of cards
;; dragged to a region and we can add these cards to the stack of the
;; target. But how do we remove these cards from the stack where the
;; cards came from? BTW The implementation of Spider loops through all
;; stacks. We do that with broadcast.

(define (reset-flowers flowers)
  (broadcast* flowers
              (face-down)
              (dim #f)
              (user-can-flip #f)
              (snap-back-after-move #t)
              (user-can-move #f))
  flowers)
(define (wiggle-flower-in-garden flower garden)
  (let* ((table (send garden get-table))
         (layout (send garden get-layout))
         (x-offset (send layout get-flower-wiggle-x-offset flower))
         (y-offset (send layout get-flower-wiggle-y-offset flower)))
    (let-values (([x y] (send table card-location flower)))
      (send table move-card flower
            (- x x-offset) (+ y y-offset))
      (send table move-card flower
            (+ x x-offset) (- y y-offset))
      (send table move-card flower x y)) ))
;;
;; Stateful Flowers
;; We don't want to save a deep copy of a view.
;; Instead we do the flag flipping ourselfs.
;; Card positions are part of the table% object state.
(define (flower-save-state flower)
  (list (send flower face-down?)
        (send flower user-can-flip)
        (send flower snap-back-after-move)
        (send flower user-can-move)
        (send flower home-region)))
(define (flower-restore-state flower state)
  (if (first state)
      (send flower face-down)
      (send flower face-up))
  (send flower user-can-flip (second state))
  (send flower snap-back-after-move (third state))
  (send flower user-can-move (fourth state))
  (send flower home-region (fifth state)))

(define (make-flowers flowers)
  (reset-flowers flowers))

;;
;; Stacks
;;
;; There are three kinds of stacks: foundations, flower beds and
;; bouquet. Layouting is done with the help of the layout hub object
;; as retrieved from the hosting garden object.
;;
;; While each card<%> object knows about its home-region, the regions
;; are not aware of these cards. To get all the cards in one region on
;; the table we could ask each card individually or keep track of all
;; the moves and maintain the missing list of cards for each stack.
;;
;; NB Asking all card objects on the table about their home-region is
;; not too time consuming, i.e. O(n), where each deck brings only 52
;; objects into the game.

(define stack%
  {class
   object%
   (init garden)
   (super-new)

   ;;
   ;; Fields
   (define cards null)
   (define my-region null)
   (define my-garden garden)

   ;; Accessors
   (define/public (get-garden) my-garden)
   (define/public (get-layout)
     (send my-garden get-layout))

   (define/public (add-card card-to-add)
     (send (send this get-garden) syncronize-stacks card-to-add)
     (set! cards (sea-cat card-to-add cards))
     (send* card-to-add
            (home-region my-region)
            ;;(stay-in-region my-region)
            )
     (send this add-card-pre-layout)
     (send (get-layout) layout-cards this)
     )

   (define/public (remove-card card-to-remove)
     (set! cards (filter {lambda (card)
                           (not (eq? card card-to-remove))}
                         cards)))

   (define/public (move-done)
     ;;(send (get-layout) layout-cards this)
     #t)

   (define/public (number-of-cards) (length cards))
   (define/public (empty?) (null? cards))
   (define/public (get-cards) cards)

   ;; Class Internal: bucket% needs this
   (define/public (set-cards bucket-cards)
     (set! cards bucket-cards))
   (define/public (add-card-pre-layout) #t)


   (define/public (get-region) my-region)
   (define/public (set-region new-region)
     (set! my-region new-region)
     ;;     (set-region-interactive-callback!
     ;;      my-region
     ;;      {lambda (finished-on-region? cards)
     ;;        (send this after-or-before-drag finished-on-region? cards)})
     )

   ;;
   ;; Stateful Object Interface
   (define/public (save-state)
     (list (sea-cat 'cards cards)
           (sea-cat 'flower-states (map flower-save-state cards))))
   (define/public (restore-state state)
     (set! cards (cast (first state)))
     (let ((flower-states (cast (second state))))
       (map flower-restore-state
            cards
            flower-states))
     ;; The coordinates of the cards are restored by the stateful
     ;; table object but it cannot save or restore the z-axis order
     ;; so we have to do some layout again.
     (send (send this get-layout) layout-cards this)
     )
   })

(define foundation%
  {class
   stack%
   (init foundation-index)
   (super-new)

   (define my-index foundation-index)

   (define (foundation-region-callback cards)
     (send (send this get-garden)
           place-on-foundation-request (wheels cards) this))

   (let ((layout (send this get-layout)))
     (send this set-region
           (make-region
            (send layout get-foundation-x-coordinate this)
            (send layout get-foundation-y-coordinate this)
            (send layout get-foundation-width this)
            (send layout get-foundation-height this)
            "Foundation"
            foundation-region-callback)))
   (send (send (send this get-garden) get-table)
         add-region (send this get-region))

   (define/public (get-foundation-index) my-index)
   })

(define flower-bed%
  {class
   stack%
   (init flower-bed-index)
   (super-new)

   (define my-index flower-bed-index)

   (define (flower-bed-region-callback cards)
     (send (send this get-garden)
           place-on-flower-bed-request (wheels cards) this))

   (let ((layout (send this get-layout)))
     (send this set-region
           (make-region
            (send layout get-flower-bed-x-coordinate this)
            (send layout get-flower-bed-y-coordinate this)
            (send layout get-flower-bed-width this)
            (send layout get-flower-bed-height this)
            #f ;"Flower Bed"
            flower-bed-region-callback)))
   (send (send (send this get-garden) get-table)
         add-region (send this get-region))

   (define/public (get-flower-bed-index) my-index)

   (define (reconfigure-cards)
     (let ((my-cards (send this get-cards)))
       (broadcast* my-cards
                   (user-can-move #f)
                   (snap-back-after-move #t))
       [when [send (send this get-garden)
                   flowers-are-laughing]
           (broadcast my-cards face-up)]
       (when (not (null? my-cards))
             (let ((top-card (wheels my-cards)))
               (when [send top-card face-down?]
                     (send (send this get-garden)
                           card-face-up top-card))
               (send top-card user-can-move #t)) )))

   ;; Table animates zero moves and each one takes time.
   ;; Do as little layout as possible even with moves on self.
   ;; But this should happen after the bucket% animation.
   ;; move-done or queue ???
;;    (define/override (remove-card flower)
;;      (let* ((cards (send this get-cards))
;;             (number-of-cards (length cards))
;;             (hit (memq flower cards)))
;;        (super remove-card flower)
;;        (when [and hit (> number-of-cards 8)] ; magic number / see layout%
;;                   (send (send this get-layout) layout-cards this))))

   (define/public (laughing-flowers)
     (reconfigure-cards))

   (define/override (move-done)
     (reconfigure-cards))
   ;;(send (send this get-layout) layout-cards this))
   })

;; According to the game play bucket% might not even be a
;; stack%. Technically speaking it does not impose any useful order
;; onto the cards but is the reserve and its layout could be done by
;; the user. Quality assurance (me when I just want to play) assured
;; us though that doing the layout by hand isn't much fun and they
;; would prefer us to do the layout for the user.
(define bucket%
  {class
   stack%
   (super-new)

   (define (bucket-region-callback cards)
     (send (send this get-garden)
           place-on-bucket-request (wheels cards) this))

   (let ((layout (send this get-layout)))
     (send this set-region
           (make-region
            (send layout get-bucket-x-coordinate this)
            (send layout get-bucket-y-coordinate this)
            (send layout get-bucket-width this)
            (send layout get-bucket-height this)
            #f ; "Bouquet"
            bucket-region-callback)))
   (send (send (send this get-garden) get-table)
         add-region (send this get-region))

   (define (prepare-card-for-bucket card)
     (when (send card face-down?) (send card face-up))
     (send* card
            ;;(face-up)
            (snap-back-after-move #f)
            (user-can-move #t)
            ))

   (define/override (add-card card)
     (prepare-card-for-bucket card)
     (super add-card card))

   (define (sort-cards-by-x-axis-order)
     (let ((table (send (send this get-garden)
                        get-table)))
       (sort (send this get-cards)
             [lambda (first-card second-card)
               (let-values (([x1 y1] (send table
                                           card-location first-card))
                            ([x2 y2] (send table
                                           card-location second-card)))
                           (< x1 x2) )])))

   (define/override (move-done)
     (send this set-cards (sort-cards-by-x-axis-order))
     (send (send this get-layout) layout-cards this))

   (define/override (add-card-pre-layout)
     (send this set-cards (sort-cards-by-x-axis-order)))

   ;;    (define/override (drag-over finished-on-region? cards)
   ;;      (send (send this get-layout) layout-cards this))
   })

;;
;; Program Action Coordinator
{define garden%
  (class
    object%
    (init shell)
    (super-new)

    ; This should be our listener but it's hardcoded.
    (define my-shell shell)

    (define number-of-foundations 4)
    (define number-of-flower-beds 6)

    (define flowers (make-flowers (make-deck)))
    (define layout (new layout96l% (unit-card (wheels flowers))))

    ;; ;; ;; ;; ;; ;; ;; ;;
    ;; This should be a subclass of table% named
    ;; flower-garden-table%
    ;; But make-table won't let us do this conveniently ???
    (define garden (make-table
                    "Open Laughing Flowers: Flower Venus Garden" ; title
                    (send layout get-table-width this)
                    (send layout get-table-height this) ))

    ;; Redefine mouse interaction. See documentation.
    (send* garden
      (set-button-action 'left 'drag-raise/one)
      (set-button-action 'middle 'drag-raise/one)
      (set-button-action 'right 'drag-raise/one))

    (define (dummy-mouse-event-handler card)
      #t)

    (send* garden
      (set-double-click-action ;dummy-mouse-event-handler)
       {lambda (flower)
         ;(debug "flower-garden-table%: double-click-action")
         (send this rescue-request flower)})
      (set-single-click-action dummy-mouse-event-handler) )
    ;;           {lambda (flower)
    ;;              (debug "flower-garden-table%: single-click-action")
    ;;             (send this selection-request flower)}))

    (send garden add-region
          (make-background-region
           (send layout get-background-x-coordinate garden)
           (send layout get-background-y-coordinate garden)
           (send layout get-background-width garden)
           (send layout get-background-height garden)
           (send layout get-background-paint-callback garden)))

    ;(send garden animated #f)  ; turn animation off altogether

    ;; flower-garden-table% Stateful Object Interface
    (define/public (table-save-state)
      (map {lambda (card)
             (let-values (([x y] (send garden card-location card)))
               (sea-cat x y))}
           flowers)) ; we could use the 'all-cards' method but ...
    (define/public (table-restore-state states)
      (for-each {lambda (card xy-pair)
                  (let ((x (wheels xy-pair))
                        (y (cast xy-pair)))
                    (send garden move-card card x y))}
                flowers
                states))

    ;; End of pseudo subclass flower-garden-table%
    ;; ;; ;; ;; ;; ;; ;; ;;

    (define my-bouquet (new flower-dialog% (garden this)))

    ;;
    ;; Create the Foundations
    ;; We could loop here or abbreviate with some lambda form
    ;; but I like to hardcode these things. A different number
    ;; of foundations makes a different game.
    (define foundations
      (list (new foundation% (garden this) (foundation-index 1))
            (new foundation% (garden this) (foundation-index 2))
            (new foundation% (garden this) (foundation-index 3))
            (new foundation% (garden this) (foundation-index 4))))

    ;;
    ;; Create the Flower Beds
    (define flower-beds
      (map {lambda (flower-bed-index)
             (new flower-bed%
                  (garden this)
                  (flower-bed-index flower-bed-index))}
           (list 1 2 3 4 5 6)))

    ;;
    ;; Create the bouquet.
    (define bouquet (new bucket% [garden this]))


    (define stack-register (append (list bouquet) flower-beds foundations))
    ;; ;; ;; ;; ;; ;; ;; ;;
    ;; This sort of extra stack handling is needed because of our
    ;; inability to subclass card% conveniently. See Flowers (flower%).
    (define/public (syncronize-stacks card)
      (broadcast stack-register remove-card card))
    ;; ;; ;; ;; ;; ;; ;; ;;


    ;;
    ;; Internal Interface
    (define/public (get-layout) layout)
    (define/public (get-table) garden)
    (define/public (card-face-up card)
      (send garden card-face-up card))
    (define/public (flower-remembered flower)
      (send layout flower-present flower))
    (define/public (flower-picked flower)
      (put-preferences '(flower-garden:background-color)
                       (list flower))
      (send layout flower-present flower)
      (clean-window))

    ;;
    ;; Stateful Object Interface
    (define/public (save-state)
      (sea-cat 'laughing flowers-laughing))
    (define/public (restore-state state)
      (set! flowers-laughing (cast state)))

    ;;
    ;; Stateful Object Management / Game States
    (define (save-game-state)
      (list (broadcast stack-register save-state)
            (send this save-state)))
      ;; It's better to not save and restore card coordinates,ie table
      ;; state. The bucket% needs to do its layout based on current
      ;; coordinates.
            ;(send this table-save-state)))
    (define (restore-game-state game-state)
      {let ([stack-states (first game-state)])
        (for-each {lambda (stack state)
                    (send stack restore-state state)}
                  stack-register
                  stack-states)}
      (send this restore-state (second game-state))
      ;; Restoring the coordinates makes the bucket fail to redo the
      ;; z-axis ordering correctly.
      ;{let ([table-state (second game-state)])
        ;(send this table-restore-state table-state)}
      #t)

    ;; Undo history is a stack of previous game states plus the
    ;; current game state.
    (define game-states '())
    (define current-game-state '())
    (define (reset-game-states)
      (set! game-states '())
      (set! current-game-state '())
      (send my-shell undo-action-disabled))
    (define (push-game-state)
      (when (not (null? current-game-state))
            (set! game-states (sea-cat current-game-state
                                       game-states)))
      (set! current-game-state (save-game-state))
      (if (null? game-states)
          (send my-shell undo-action-disabled)
          (send my-shell undo-action-enabled)))
    (define (pop-game-state)
      (if [not [null? game-states]]
          {let ([last-game-state (first game-states)])
            (restore-game-state last-game-state)
            (set! current-game-state last-game-state)
            (set! game-states (cast game-states))
            (when (null? game-states)
                  (send my-shell undo-action-disabled))}
          (debug "garden%: pop-game-state called but game-states is empty")))

    ;;
    ;; Rule Implementation Interface
    ;;
    ;; Where one part of a card game's rules usually becomes the game
    ;; mechanic, i.e. layout and user interaction, another part becomes
    ;; the game's logic. For convenience this is implemented here as
    ;; something that resembles a controller.
    ;;
    ;; To allow different difficulty levels we might want to introduce
    ;; flower-garden-ruleset<%> objects and delegate these calls to the
    ;; one representing the current ruleset.

    (define empty? null?)

    (define (move-done)
      (broadcast flowers dim #f)
      (broadcast stack-register move-done)
      (push-game-state))

    (define (initial-deal)
      ;; Clear the undo history. (The shuffle shuffles its contents.)
      (reset-game-states)

      ;; Prepare our card game.
      (set! flowers (shuffle-list flowers 6))

      ;; Throw the seeds. It's reversed to make them fly over not
      ;; under. This deals the cards visually from the bottom of the
      ;; deck. But when dealing from its top we would have to
      ;; re-stack-cards, i.e. changing the z-axis ordering, for the
      ;; whole table all the time.
      (send garden add-cards (reverse flowers)
            (send layout get-initial-deal-x-coordinate this)
            (send layout get-initial-deal-y-coordinate this))

      (let ((flowers flowers))
        ;; Deal 6 cards on each flower bed.
        (repeat 6 {lambda ()
                    (for-each {lambda (flower-bed)
                                (send flower-bed add-card
                                      (wheels flowers))
                                (set! flowers (cast flowers))}
                              flower-beds)} )
        [with-card-animation*
         garden
         ;; Cut the flowers' wheels.
         ;(broadcast (map wheels (broadcast flower-beds get-cards))
         ;           face-up)
         (for-each {lambda (card)
                     (send garden card-face-up card)}
                   (map wheels (broadcast flower-beds get-cards)))
                   
         ;; Deal the remaining cards into the bucket.
         (for-each {lambda (flower)
                     (send bouquet add-card flower)}
                   flowers)
         ] ; close animation
        ) ; let all flowers dealt
      (move-done))

    (define (can-place-on-flower-bed? flower flower-bed)
      (let ((stacked (send flower-bed get-cards)))
        [or (empty? stacked)
            (and (card-one-rank-below? flower (wheels stacked))
                 (card-same-suit? flower (wheels stacked)))] ))
    (define (place-on-flower-bed-request/private flower flower-bed)
        (when [can-place-on-flower-bed? flower flower-bed]
          (send flower-bed add-card flower)
          (move-done) ))
    (define/public (place-on-flower-bed-request flower flower-bed)
      (ignore-when-busy
       {lambda ()
         (place-on-flower-bed-request/private flower flower-bed)}))

    (define (game-is-won?)
      (define (foundation-full? foundation)
        (let ((stacked (send foundation get-cards)))
          (and (not (null? stacked))
               (card-is-king? (wheels stacked))) ))
      (define (game-is-won? foundations)
        (if (null? foundations)
            #t
            (and (foundation-full? (wheels foundations))
                 (game-is-won? (cast foundations))) )) ; not tail recursive
      (game-is-won? foundations))

    (define (can-place-on-foundation? flower foundation)
      (let ((stacked (send foundation get-cards)))
        [or (and (empty? stacked)
                 (card-is-ace? flower))
            (and (not (empty? stacked))
                 (card-same-suit? flower (wheels stacked))
                 (card-one-rank-above? flower (wheels stacked)))]))
    (define (place-on-foundation-request/private flower foundation)
        (when [can-place-on-foundation? flower foundation]
          (send foundation add-card flower)
          (move-done)
          (when (game-is-won?)
                 (queue-with-busy
                  {lambda ()
                    (debug "game-is-won: (queued): start flower-present")
                    (send my-bouquet flower-present)
                    (debug "game-is-won: (queued): calling queue-reset-game")
                    (send this queue-reset-game) })
                )))
    (define/public (place-on-foundation-request flower foundation)
      (ignore-when-busy
       {lambda ()
         (place-on-foundation-request/private flower foundation)}))

    (define (is-playable? flower)
      (and (send flower user-can-move)
           (not (send flower face-down?))))

    (define (rescue-request/private flower)
      (when [is-playable? flower]
        (for-each {lambda (foundation)
                    (place-on-foundation-request/private flower foundation)}
                  foundations)))
    (define/public (rescue-request flower)
      (ignore-when-busy
       {lambda ()
         (rescue-request/private flower)}))

    (define (can-place-on-bucket? flower bucket)
      [< (send bucket number-of-cards) 16])
    (define (place-on-bucket-request/private flower bucket)
      (when [can-place-on-bucket? flower bucket]
            (send bucket add-card flower)
            (move-done) ))
    (define/public (place-on-bucket-request flower bucket)
      (ignore-when-busy
       {lambda ()
         (place-on-bucket-request/private flower bucket)}))

    ;; Live Variations / Rule Variants
    (define flowers-laughing #f)
    (define/public (flowers-are-laughing) ; internal interface
      flowers-laughing)

    ;; Hint System
    ;;
    ;; Wiggle some flowers that are playable and have a useful
    ;; destination.  First we try to find rescuable flowers that can
    ;; be put on a foundation from either the bucket or a flower bed.
    ;; If that fails we try to find flowers for exchange between
    ;; flower beds and bucket. We might offer a new deal when no more
    ;; moves are possible.
    (define (is-rescuable? flower)
      (apply-or
       (map [lambda (foundation)
              (can-place-on-foundation? flower foundation)]
            foundations)))
    
    (define (top-cards flower-beds)
      (map wheels (filter [lambda (flower) (not (null? flower))]
                          (broadcast flower-beds get-cards))))
    (define (get-rescuable-flowers)
      "Return a list of all cards that can be placed on a foundation."
      (filter is-rescuable?
              (append (top-cards flower-beds)
                      (send bouquet get-cards))))
    (define (can-place-on-any-flower-bed? flower)
      (apply-or (map [lambda (flower-bed)
                       (can-place-on-flower-bed? flower flower-bed)]
                     flower-beds)))
    (define (can-place-on-bouquet? flower)
      (can-place-on-bucket? flower bouquet))
    (define (get-left-moves)
      (let ((flower-bed-playable-flowers
             (filter is-playable?
                     (top-cards flower-beds))))
        (append
         (filter can-place-on-any-flower-bed? flower-bed-playable-flowers)
         (filter can-place-on-any-flower-bed? (send bouquet get-cards))
         (filter can-place-on-bouquet? flower-bed-playable-flowers))))

    (define (no-more-moves)
      (when
       [eq? 'yes
            (message-box
             "New Deal?"
             " Oh dear, you're stuck!
Rien ne va plus! No moves, no more ...

 Do you want to have another deal?"
             garden
             '(yes-no))]
       (queue-reset-game)))
    (define (dealers-hint)
      (let ((rescuable-flowers (get-rescuable-flowers)))
        (debug "dealers-hint: rescuable-flowers: "
               (length rescuable-flowers))
        (if (not (null? rescuable-flowers))
            (for-each {lambda (flower)
                        (wiggle-flower-in-garden flower this)}
                      rescuable-flowers)
            (let ((right-moves (get-left-moves)))
              (debug "dealers-hint: possible moves: "
                     (length right-moves))
              (if [not (null? right-moves)]
                  (wiggle-flower-in-garden (wheels right-moves)
                                           this)
                  {no-more-moves})) )))

    ;;
    ;; This is a workaround. There is a redrawing shortcoming when we
    ;; change the background color. It might be related to the way
    ;; regions are used, how the clipping is handled and the way Cairo
    ;; is fed with these things by the Virtual Cards Library. Without
    ;; that redrawing shortcoming it's still looks funny and it
    ;; usually happens only after a game is won and the next deal.
    (define (clean-window)
      (let ((flowers (send garden all-cards)))
        (if (null? flowers)
            'sponge-not-found   ; no sponge there at startup
            (send layout clean-window-in-garden
                  ;; we use the top most flower as the sponge
                  (wheels flowers)
                  garden)) ))
    

    ;;
    ;; Parallel Objects
    ;;  Shared Unit: Display via table / Animation System
    ;;  Policy for all entry points: ignore when busy
    ;;   Rule Implementation Interface, Application Interface
    ;;
    
    (define busy (make-semaphore 1))
    (define my-mutex #f) ; non-atomic mutex
    (define (ignore-when-busy thunk)
      (if (semaphore-try-wait? busy)
          (begin (if my-mutex
                     (warning "ignore-when-busy: mutex check failed")
                     (begin (set! my-mutex #t)
                            (thunk)
                            (set! my-mutex #f)))
                 (semaphore-post busy))
          (begin (debug "ignore-when-busy: code red")
                 (bell) )))
    (define (queue-with-busy thunk) ; XXX avoid dead locks
      (queue-callback 
       {lambda ()
         (semaphore-wait busy)
         (if my-mutex
             (warning "queue-with-busy: (queued): mutex check failed")
             (begin (set! my-mutex #t)
                    (thunk)
                    (set! my-mutex #f)))
         (semaphore-post busy)}))

    ;;;
    ;;; Application Interface
    ;;;

    (define/public (grow)
      (send garden show #t)
      (ignore-when-busy
       {lambda ()
         (w/o-card-animation garden initial-deal)}))

    (define (reset-game/private)
      [w/o-card-animation* garden
        (debug "reset-game/private: start")
        ;; remove cards from the stacks (from the model)
        (for-each {lambda (card)
                    (broadcast stack-register remove-card card)}
                  flowers)
        ;; remove cards from the table (from the view)
        (send garden remove-cards flowers)
        
        (set! flowers-laughing #f)
        (reset-flowers flowers)
        (initial-deal)
        (debug "reset-game/private: end") ] )
    (define/public (queue-reset-game)
      (queue-with-busy reset-game/private))
    (define/public (reset-game)
      (ignore-when-busy
       {lambda ()
         (when (eq? 'yes
                    (message-box
                     "New Deal"
                     "Are you sure you want to have another deal?"
                     garden
                     '(yes-no)))
               (reset-game/private))}))

    (define/public (undo)
      (ignore-when-busy
       {lambda ()
         (w/o-card-animation garden pop-game-state)}))

    (define (laughing-flowers/private)
      (when (not flowers-laughing) 
            (set! flowers-laughing #t) ; ??? disable menu item
            (broadcast flower-beds laughing-flowers)
            (move-done)))
    (define/public (laughing-flowers)
      (ignore-when-busy laughing-flowers/private))

    (define (flower-preset/private)
      (send my-bouquet flower-present))
    (define/public (flower-preset)
      (ignore-when-busy flower-preset/private))

    (define/public (hint)
      (ignore-when-busy dealers-hint))

    (define/public (window-cleaner)
      (ignore-when-busy clean-window))
    )}


;;
;; Application Classes / Menu and System Interface
;;

;; Racket/OS X Shell
(define flower-garden%
  {class
      object%
    (super-new)

    ;;
    ;; Preferences
    (define default-background-color "Cornflower Blue")
    (define/public (get-table-background)
      (get-preference 'flower-garden:background-color
                      (lambda () default-background-color)))

    ;;
    ;; Flower Garden App Construction
    (define garden (new garden% [shell this]))
    (define main-frame (send garden get-table))
    ;; XXX the menu with parent 'root does not appear on screen
    (define my-menu-bar (make-object menu-bar% main-frame)) ;'root))
    (define my-game-menu (make-object menu% "Game" my-menu-bar))
    (define my-extra-menu (make-object menu% "Extra" my-menu-bar))
    
    (define flower-preset-menu-item
      (new menu-item%
           [label "Flower Preset"]
           [parent my-extra-menu]
           [callback
            {lambda {i e} (send garden flower-preset)}]))
    (define window-cleaner-menu-item
      (new menu-item%
           [label "Window Cleaner"]
           [parent my-extra-menu]
           [callback
            {lambda {i e} (send garden window-cleaner)}]))

    (new menu-item%
         [label "Laughing Flowers"]
         [parent my-game-menu]
         [callback
          {lambda {i e} (send garden laughing-flowers)}])
    (new separator-menu-item% [parent my-game-menu])
    (define hint-menu-item
      (new menu-item%
           [label "Dealer's Hint"]
           [parent my-game-menu]
           [callback
            {lambda {i e} (send garden hint)}]))
    (new menu-item%
         [label "New Deal"]
         [parent my-game-menu]
         [callback
          {lambda (i e) (send garden reset-game)} ])
    (define undo-action-menu-item
      (new menu-item%
           [label "Take back Move"]
           [parent my-game-menu]
           [callback
            {lambda {i e} (send garden undo)}]))
    (new separator-menu-item% [parent my-game-menu])
    ;(define my-edit-menu (make-object menu% "Edit" my-menu-bar))
    (new menu-item%
         [label "Leave Table"]
         [parent my-game-menu]
         [callback {lambda (i e)
                     (send main-frame show #f)
                     (exit)}])

    ;; Internal Interface
    ;; This should be encapsulated in an undo action object.
    (define/public (undo-action-enabled)
      (send undo-action-menu-item enable #t))
    (define/public (undo-action-disabled)
      (send undo-action-menu-item enable #f))

    ;; Start the show!
    (send garden flower-remembered (send this get-table-background))
    (send garden grow)
    })


;;
;; Garbage Collection / JIT Compiler
;;

;; The JIT compiler is too time consuming for our game.
(eval-jit-enabled #f)


;;
;; Program Startup
;;

(define sort-deck (new flower-garden%))